home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - Mac 68K / demos / html2txt / html2txt.dylan < prev    next >
Encoding:
Text File  |  1995-03-15  |  31.6 KB  |  830 lines  |  [TEXT/MPCC]
  1. module:        HTML
  2. Author:        Robert Stockton (rgs@cs.cmu.edu)
  3. synopsis:    Converts a file in WWW "HyperText Markup Language" into
  4.             formatted text.  Provides a small demo of a 'complete
  5.             application' in Dylan.
  6.  
  7. //======================================================================
  8. //
  9. // Copyright (c) 1994  Carnegie Mellon University
  10. // All rights reserved.
  11. // 
  12. // Use and copying of this software and preparation of derivative
  13. // works based on this software are permitted, including commercial
  14. // use, provided that the following conditions are observed:
  15. // 
  16. // 1. This copyright notice must be retained in full on any copies
  17. //    and on appropriate parts of any derivative works.
  18. // 2. Documentation (paper or online) accompanying any system that
  19. //    incorporates this software, or any part of it, must acknowledge
  20. //    the contribution of the Gwydion Project at Carnegie Mellon
  21. //    University.
  22. // 
  23. // This software is made available "as is".  Neither the authors nor
  24. // Carnegie Mellon University make any warranty about the software,
  25. // its performance, or its conformity to any specification.
  26. // 
  27. // Bug reports, questions, comments, and suggestions should be sent by
  28. // E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  29. //
  30. //======================================================================
  31.  
  32. //======================================================================
  33. // This program is a filter which converts text in WWWs "HyperText Markup
  34. // Language" into simple formatted text.  Although it is a complete and useful
  35. // application, it is included in this distribution primarily as a
  36. // demonstration of a "real" (albeit small) Dylan (tm) program.
  37. //
  38. // Usage is typical for a UNIX (tm) program.  It may be invoked either with a
  39. // set of files on the command line:
  40. //   mindy -f html2txt.dbc file1.html file2.html ....
  41. // or with no arguments, in which case it reads from "standard input".  At
  42. // present, it accepts no command line switches, although the behavior may be
  43. // changed by changing several constant declarations towards the top of this
  44. // source file.
  45. //
  46. // On most unix systems you should be able to make it into an executable
  47. // script by prepending the the line
  48. //   #!BINDIR/mindy -f
  49. // to the compiled "dbc" file.  You must, of course, remember to specify the
  50. // MINDYPATH environment variable so that it points to the libraries "dylan",
  51. // "streams", "collection-extensions", and "string-extensions".
  52. //
  53. // The basic translation strategy used by html2txt is to scan the file line by
  54. // line, looking for HTML "tags" and accumulating text that lies between any
  55. // two tags.  For each tag type, there is a set of routines (stored in tables)
  56. // which define the appropriate actions for starting and ending the
  57. // "environment" defined by the tag and for dumping the collected text from
  58. // within that environment as formatted text.  A basic control loop in
  59. // "process-HTML" is responsible for calling the appropriate tag actions.
  60. // This routine may be called recusively by some of the tag actions.
  61. //
  62. // The "interface" between adjacent environments is handled via the "blank"
  63. // parameter which is passed around extensively.  This variable states whether
  64. // a blank line has just been printed.  Thus environments which believe that
  65. // they must be preceded or followed by a blank line can determine whetehr
  66. // they must do anything about it, and we lessen the risk that multiple
  67. // routines will emit blank lines when we only want a maximum of one.
  68. //
  69. // The primary advantage of this organization is that it allows the
  70. // specialized actions for a single tag to be grouped together, and allows new
  71. // tags to be cleanly added.  It benefits greatly from Dylan's ability to
  72. // create anonymous methods and manipulate them as first class data objects,
  73. // as well as from the rich set of available collection types.
  74. //======================================================================
  75.  
  76. // Because the entire application is contained in a single file, it is easiest
  77. // to define its library and module "inline".  This capability may not be
  78. // supported by all Dylan implementations, since the "file exchange format" is
  79. // not terribly well defined at present.
  80. define library html
  81.   use dylan;
  82.   use streams;
  83.   use collection-extensions;
  84.   use string-extensions;
  85. end library html;
  86.  
  87. define module html
  88.   use dylan;
  89.   
  90.   // A few basic definitions not present in the Dylan spec
  91.   use extensions, import: {<boolean>, main};
  92.   
  93.   // Additional collection classes and operations from "collection-extensions"
  94.   use subseq;
  95.   use self-organizing-list;
  96.  
  97.   // From string-extensions:
  98.   use substring-search;
  99.   
  100.   // I/O support from the "streams" library
  101.   use streams;
  102.   use standard-io;
  103.   
  104.   export html2text;
  105. end module html;
  106.  
  107. // Basic constants
  108. define constant <strings> = <stretchy-vector>;
  109. define variable *linelen* :: <integer> = 78;
  110. define variable *margin* :: <integer> = 2;
  111.  
  112. define variable *H1cap* :: <boolean> = #t;
  113. define variable *H1under* :: <boolean> = #t;
  114. define variable *H2cap* :: <boolean> = #t;
  115. define variable *H2under* :: <boolean> = #t;
  116. define variable *Bcap* :: <boolean> = #t;
  117. define variable *Icap* :: <boolean> = #t;
  118.  
  119. // Internal constants
  120. define variable Pre-Count :: <integer> = 0;
  121. define variable prefix :: <string> = "";
  122. define variable counter :: <integer> = 0;
  123.  
  124. // We can use hash tables for looking up tag processing routines, but "self
  125. // organizing lists" tend to provide better performance in this case.  Since
  126. // they are completely interchangeable, you can try switching the definition
  127. // here to swap in the "standard" table support instead.
  128.  
  129. define constant <tag-table> = <self-organizing-list>;
  130. // define constant <tag-table> = <object-table>;
  131.  
  132.  
  133. //////////////////////////////////////////////////////////////////////////
  134. //                   String Utilities                //
  135. //////////////////////////////////////////////////////////////////////////
  136.  
  137. // Find the index of first element (after "from") of a sequence which
  138. // satisfies the given predicate.  (Like find-key, but guaranteed sequential
  139. // and accepts start: and end: rather than skip:.)
  140.  
  141. // This program makes heavy use of start: and end: keywords (in order to avoid
  142. // copying subsequences).  Find-key would have been completely unsuitable for
  143. // this unless we used <subsequence>s to refer to slices of existing
  144. // sequences, and even then the efficiency penalty would have been high.  It
  145. // therefore seemed better to simply define new routines to do "the right
  146. // thing". 
  147. define method sfind(seq :: <sequence>, pred?, 
  148.             #key start: start = 0,
  149.                  end: last, failure: fail)
  150.   block (return)
  151.     let last = if (last) min(last, size(seq)) else size(seq) end if;
  152.     for (i :: <integer> from start below last)
  153.       if (pred?(seq[i])) return(i)  end if;
  154.     finally 
  155.       fail;
  156.     end for;
  157.   end block;
  158. end method sfind;
  159.  
  160. // Like sfind, but goes backward from the end (or from before end:).
  161. define method rsfind(seq :: <sequence>, pred?,
  162.              #key start: start = 0,
  163.                   end: last, failure: fail)
  164.   block (return)  
  165.     let last = if (last) min(last, size(seq)) else size(seq) end if;
  166.     for (i from last - 1 to start by -1) 
  167.       if (pred?(seq[i])) return(i)  end if;
  168.     finally 
  169.       fail;
  170.     end for;
  171.   end block;
  172. end method rsfind;
  173.  
  174. // The notation "'!' * 5" is a good way to create a string of repeated
  175. // characters.  This variety of overloaing is becoming popular in several
  176. // modern languages (i.e. C++, Perl, and Ada).
  177. define method \*(ch :: <character>,
  178.          times :: <integer>)  => (result :: <byte-string>);
  179.   make(<byte-string>, size: times, fill: ch) 
  180. end method \*;
  181.  
  182. ////////////////////////////////////////////////////////////////////////
  183. //                 Basic HTML Utilities              //
  184. ////////////////////////////////////////////////////////////////////////
  185.  
  186. // Simply a conventient shorthand for writing to *standard-output*.
  187. define method write-string(string :: <string>)
  188.   write(string, *standard-output*);
  189. end method write-string;
  190.  
  191. // Print a line according to *margin* and *linelen*.  Add special handling for
  192. // *prefix* hack.  Streams don't automatically flush output at the ends of
  193. // lines, so we flush the output ourselves to allow the output to be viewed
  194. // interactively. 
  195. define method print-with-prefix(str :: <string>, #rest args) 
  196.   for (i from 1 to *margin* - size(prefix))
  197.     write(' ', *standard-output*);
  198.   end for;
  199.   write-string(prefix); 
  200.   apply(write-line, str, *standard-output*, args);
  201.   prefix := "" ;
  202.   force-output(*standard-output*);
  203. end method print-with-prefix;
  204.  
  205. // As mentioned above, "tag action routines" are stored in tables for easy
  206. // reference.  They are keyed by symbols corresponding to the tag (i.e.
  207. // #"text"). 
  208. define constant add-text-table :: <tag-table> = make(<tag-table>);
  209.  
  210. // The heavy duty search and replace operations in "add-text" are in the
  211. // critical path, so it is worth optimizing these by pre-computing the search
  212. // tables.  For more details, look at the "string-search" module in
  213. // "extensions". 
  214. define constant tab-to-space
  215.   = make-substring-replacer("\t", replace-with: " ");
  216. define constant convert-lt
  217.   = make-substring-replacer("<", replace-with: "<");
  218. define constant convert-gt
  219.   = make-substring-replacer(">", replace-with: ">");
  220. define constant convert-amp
  221.   = make-substring-replacer("&", replace-with: "&");
  222.  
  223. // Accumulates text within a single tag environment.  The appropriate tag
  224. // action routine is called to transform the given text.  This may be
  225. // "identity", "as-uppercase", or any other arbitrary action.
  226. // This routine also transforms "quoted characters" (such as "<" for '<')
  227. // into their ascii equivalents and crunches tabs down into spaces.
  228. define method add-text(tag :: <symbol>, text :: <strings>,
  229.                new-text :: <string>) => (result :: <strings>);
  230.   // replace-substring only works on <byte-string>s.
  231.   let new-text :: <string> =
  232.     as(<byte-string>, new-text);
  233.   let Tab-Free :: <string> =
  234.     if (Pre-Count = 0)
  235.       tab-to-space(new-text);
  236.     else
  237.       new-text;
  238.     end if;
  239.   let AMP :: <string> = convert-amp(convert-lt(convert-gt(Tab-Free)));
  240.   
  241.   let new-text = element(add-text-table, tag, default: identity)(AMP);
  242.   
  243.   if (empty?(new-text)) text else add!(text, new-text) end;
  244. end method add-text;
  245.  
  246. // Special processing is required when newlines are encountered in the input
  247. // stream.  If we are in a "<PRE>" environment, then we simply include a
  248. // newline in the output.  If we are in any other environment, we must guess
  249. // the correct number of spaces to put in based upon the punctuation of the
  250. // previous line.
  251. define method add-eol(text :: <strings>) => (result :: <strings>);
  252.   if (Pre-Count > 0) 
  253.     add!(text, "\n") 
  254.   else
  255.     let Prev-Str = last(text, default: "");
  256.     if (Prev-Str.empty?)
  257.       text;
  258.     else
  259.       let space = 
  260.     select (Prev-Str.last)
  261.       '.', ':', '!', '?' =>
  262.         "  ";
  263.       '-', ' ' =>
  264.         "";
  265.       otherwise =>
  266.         " ";
  267.     end select;
  268.       add!(text, space);
  269.     end if;
  270.   end if 
  271. end method add-eol;
  272.  
  273. // The "break-up" routines produce and print appropriate formatted text from
  274. // the accumulated data.  The action defaults to the #"text" action, which
  275. // breaks the text into lines (at word boundaries)according to the defined
  276. // margins.  "break-up" then clears the accumulated text before returning
  277. // control to the main loop.
  278. define constant break-up-table :: <tag-table> = make(<tag-table>);
  279. define method break-up(tag :: <symbol>, text :: <strings>, 
  280.                blank :: <boolean>,
  281.                want-blank :: <boolean>) => (result :: <boolean>);
  282.   let full-text = if (text.empty?) "" else apply(concatenate, text) end;
  283.   block ()
  284.     break-up-table[tag](full-text, blank, want-blank);
  285.   exception <error>
  286.     break-up-table[#"TEXT"](full-text, blank, want-blank);
  287.   cleanup
  288.     size(text) := 0;
  289.   end block;
  290. end method break-up;
  291.  
  292. // Tag close defines the appropriate action to take at the end of an
  293. // environment (i.e. when encountering "</PRE>".  This may be a null action,
  294. // or may call "break-up" to dump the accumulated text, or may perform any
  295. // other arbitrary action.
  296. define constant tag-close-table :: <tag-table> = make(<tag-table>);
  297. define method tag-close(tag :: <symbol>, close :: <symbol>,
  298.             text :: <strings>, blank :: <boolean>)
  299.     => (result :: <boolean>);
  300.   if (tag ~= close) 
  301.     signal(concatenate("Tag mismatch: <", as(<string>, tag), "> vs. </",
  302.                as(<string>, close), ">.\n"))  
  303.   end if;
  304.   block ()
  305.     tag-close-table[tag](tag, text, blank);
  306.   exception <error>
  307.     tag-close-table[#"TEXT"](tag, text, blank);
  308.   end block;
  309. end method tag-close;
  310.  
  311. // Tag start defines the appropriate action to take at the beginning of an
  312. // environment (i.e. when encountering "<PRE>".  This may be a null action,
  313. // or may call "break-up" to dump the accumulated text, or may perform any
  314. // other arbitrary action.
  315. define constant tag-start-table :: <tag-table> = make(<tag-table>);
  316. define method tag-start(New-Tag :: <symbol>, Old-Tag :: <symbol>,
  317.             Out-Text :: <strings>, Current-Text :: <string>, 
  318.             File :: <stream>, blank :: <boolean>)
  319.     => (New-Text :: <string>, blank :: <boolean>);
  320.   let fun = block ()
  321.           tag-start-table[New-Tag];
  322.         exception <error>
  323.           signal("Unknown tag type: <%=>\n", New-Tag);
  324.           tag-start-table[#"TEXT"];
  325.         end block;
  326.   fun(New-Tag, Old-Tag, Out-Text, Current-Text, File, Blank);
  327. end method tag-start;
  328.  
  329. // This routine is called at "load time" to build the tag action tables.  Note
  330. // that "reasonable" defaults are defined for all actions so that only the
  331. // "specialized" actions for any given environment need be specified.
  332. define method add-tag(tags :: <sequence>,
  333.               #key add-text: AT = identity,
  334.                    break-up: BU = break-up-table[#"TEXT"],
  335.                    tag-close: TC = tag-close-table[#"TEXT"],
  336.                    tag-start: TS = tag-start-table[#"TEXT"])
  337.   for (tag in tags)
  338.     let Tag-Symbol = as(<symbol>, tag);
  339.     add-text-table[Tag-Symbol] := AT;
  340.     break-up-table[Tag-Symbol] := BU;
  341.     tag-close-table[Tag-Symbol] := TC;
  342.     tag-start-table[Tag-Symbol] := TS;
  343.   end for;
  344. end method add-tag;
  345.  
  346. ////////////////////////////////////////////////////////////////////////
  347. //                 Main Driver Routines              //
  348. ////////////////////////////////////////////////////////////////////////
  349.  
  350. // This is the workhorse routines.  It reads in new data, searches for tags,
  351. // and dispatches the appropriate "add-text", "tag-start", and "tag-close"
  352. // routines.  It also attempts to unwind gracefully when it encounters the end
  353. // of the file, since many HTML data files fail to terminate all environments.
  354. define method process-HTML(Tag :: <symbol>, Out-Text :: <strings>, 
  355.                Current-Text :: <string>, File :: <stream>,
  356.                blank :: <boolean>)
  357.     => (Current-Text :: <string>, blank :: <boolean>);
  358.   
  359.   local method is-space(ch) ch == ' ' | ch == '\t' end method;
  360.   local method tag-end(ch) ch == ' ' | ch == '\t' | ch == '>' end method;
  361.   local method not-space(ch) ch ~= ' ' & ch ~= '\t' end method;
  362.   
  363. //  break("process-HTML");
  364.   
  365.   block (return)
  366.     while (#t)
  367.   
  368.       // keep crunching until EOF causes us to call "return"
  369.       let Start-Tag = sfind(Current-Text, curry(\==, '<'));
  370.       if (Start-Tag)
  371.         // There is a tag on this line, so we accumulate the text which
  372.         // precedes it and then invoke the appropriate tag actions.
  373.         Out-Text := add-text(Tag, Out-Text,
  374.                     subsequence(Current-Text, end: Start-Tag));
  375.     
  376.         // If a newline occurs within a tag, we must keep reading until we get
  377.         // the rest of the tag.  Whitespace is simply used as a separator, so
  378.         // we substitute a space for the newline.
  379.         let End-Tag =
  380.           for (index = sfind(Current-Text, curry(\==, '>'), start: Start-Tag)
  381.               then sfind(Current-Text, curry(\==, '>'), start: Start-Tag),
  382.               until index)
  383.                 Current-Text := concatenate(Current-Text, " ", read-line(File));
  384.               finally index;
  385.           end for;
  386.     
  387.         // Find the complete tag and figure out whether it is "opening" or
  388.         // "closing" an environment.
  389.         let first = sfind(Current-Text, not-space, start: Start-Tag + 1);
  390.         let Is-Close = Current-Text[first] = '/'; 
  391.         if (Is-Close)
  392.           first := sfind(Current-Text, not-space, start: first + 1)
  393.         end if; 
  394.     let New-Tag =
  395.       as(<symbol>, copy-sequence(Current-Text, start: first, 
  396.                      end: sfind(Current-Text, tag-end,
  397.                         start: first)));
  398.     // Call the appropriate action for the tag.  This may invoke
  399.     // a recursive call to "process-HTML" for start tags and will exit
  400.     // this recusive call for closing tags.
  401.     Current-Text := copy-sequence(Current-Text, start: End-Tag + 1);
  402.     if (Is-Close)
  403.       return(Current-Text, tag-close(Tag, New-Tag, Out-Text, blank));
  404.     else 
  405.       let (New-Text, NewBlank) = 
  406.         tag-start(New-Tag, Tag, Out-Text, Current-Text, File, blank);
  407.       Current-Text := New-Text;
  408.       blank := NewBlank; 
  409.     end if;
  410.       else
  411.     // Process newlines.  We ignore indentation in the next line unless we
  412.     // are inside a "<PRE>" environment.
  413.     Out-Text := add-eol(add-text(Tag, Out-Text, Current-Text));
  414.     let (New-Text, eof) = read-line(File);
  415.     let First-Real = if (Pre-Count = 0)
  416.                sfind(New-Text, not-space, failure: 0);
  417.              else 0
  418.              end if;
  419.     Current-Text := if (First-Real > 0)
  420.               copy-sequence(New-Text, start: First-Real);
  421.             else
  422.               New-Text;
  423.             end if;
  424.       end if;
  425.     end while;
  426.   exception <end-of-file>
  427.     // End of file processing.  Dump accumulated text and then exit.
  428.     let blank = break-up(Tag, Out-Text, blank, #f);
  429.     values("", blank);
  430.   end block 
  431. end method process-HTML;
  432.  
  433. // specialized routines to open various sourts of streams and invoke
  434. // "process-HTML".
  435. define method html2text(fd :: <stream>) => ();
  436.   process-HTML(#"TEXT", make(<strings>), "", fd, #t);
  437.   force-output(*standard-output*);
  438. end method html2text;
  439.  
  440. define method html2text(file :: <string>) => ();
  441.   let stream = make(<file-stream>, name: file);
  442.   html2text(stream);
  443. end method html2text;
  444.  
  445. define method html2text(file == #t) => ();
  446.   html2text(make(<fd-stream>, fd: 0));
  447. end method html2text;
  448.  
  449. // Trivial main program -- just invokes "html2text" which in turn invokes
  450. // "process-HTML".  Note that we had to import the generic function "main"
  451. // from module "extensions" in library "dylan".  This interface is Mindy
  452. // specific. 
  453. define method main (argv0, #rest args) => ();
  454.   if (empty?(args))
  455.     html2text(#t);
  456.   else
  457.     map(html2text, args);
  458.   end if;
  459. end method main;
  460.  
  461. ////////////////////////////////////////////////////////////////////////
  462. //            Specific Environment Routines              //
  463. ////////////////////////////////////////////////////////////////////////
  464.  
  465. // The anonymous methods here implement the appropriate tag actions for all of
  466. // the tags currently supported.  Some are quite straightforward, while others
  467. // may require a twisted mind to "properly appreciate" them.  This
  468. // organization does, at least, allow the processing of most tags to be
  469. // isolated so that you needn't grok all the code at once.
  470.  
  471. add-tag(#["TEXT"],           // Default environment
  472.     // Performs a "paragraph break" and recursively processes the new
  473.     // environment
  474.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  475.                Out-Text :: <strings>, Current-Text :: <string>,
  476.                File :: <stream>, blank :: <boolean>)
  477.                => (result :: <string>, blank :: <boolean>);
  478.              let blank = break-up(Old-Tag, Out-Text, blank, #t);
  479.              process-HTML(New-Tag, Out-Text, Current-Text,
  480.                   File, blank);
  481.            end method,
  482.     // Performs a "paragraph break" and returns to the enclosing
  483.     // environment
  484.     tag-close: method (tag :: <symbol>, text :: <strings>,
  485.                blank :: <boolean>) => (result :: <boolean>);
  486.              break-up(tag, text, blank, #t);
  487.            end method,
  488.     // Breaks "text" into lines according to *margin* and *linelen*.
  489.     // Parameters blank and want-blank say whether there is a blank line
  490.     // before the current text and whether there should be one after the
  491.     // current text.  The return value tells whether a blank line was
  492.     // printed.
  493.     break-up: method (text :: <string>, blank :: <boolean>, 
  494.               want-blank :: <boolean>)  => (result :: <boolean>);
  495.             let first = sfind(text, curry(\~=, ' ')); 
  496.             if (~first) 
  497.               if (want-blank & ~blank) write-string("\n")  end if;
  498.               blank | want-blank 
  499.             else
  500.               let Text-Size = size(text);
  501.               let Find-Break = 
  502.             method (first, last)
  503.               if (last >= Text-Size)
  504.                 Text-Size;
  505.               else 
  506.                 let find = rsfind(text, curry(\=, ' '),
  507.                           start: first, end: last); 
  508.                 if (find)   
  509.                   rsfind(text, curry(\~=, ' '), 
  510.                      start: first, end: find) + 1 
  511.                 else 
  512.                   sfind(text, curry(\=, ' '), start: first)
  513.                 | size(text)
  514.                 end if
  515.               end if
  516.             end method; 
  517.               while (first)
  518.             let last = Find-Break(first,
  519.                           first + *linelen* - *margin*);
  520.             print-with-prefix(text, start: first, end: last); 
  521.             first := sfind(text, curry(\~=, ' '), start: last + 1)
  522.               end while; 
  523.               if (want-blank) write-string("\n")  end if; 
  524.               want-blank 
  525.             end if 
  526.           end method);
  527.  
  528. // This tag action is used for many different tags -- it simply invokes
  529. // "process-HTML" recursively without doing anything special to the
  530. // accumulated text.  This is handy for "lightweight" enviromentents like
  531. // "<I>". 
  532. define constant tag-start-recurse =
  533.   method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  534.       Out-Text :: <strings>, Current-Text :: <string>, 
  535.       File :: <stream>, blank :: <boolean>)
  536.       => (result :: <string>, blank :: <boolean>);
  537.     process-HTML(New-Tag, Out-Text, Current-Text, File, blank);
  538.   end method;
  539.  
  540. // This tag action is a logical partner for "tag-start-recurse".  It simply
  541. // exits so that control will return to an inclosing "process-HTML" call
  542. // without distrubing the accumulated text.
  543. define constant tag-close-nothing =
  544.   method (tag :: <symbol>, Out-Text :: <strings>, blank :: <boolean>)
  545.     blank;
  546.   end method;
  547.  
  548. // Specialized "add-text" methods provide EMPHASIZED versions of "<B>" or
  549. // "<I>" style environments.
  550. add-tag(#["I", "EM", "CITE", "VAR", "DFN"],
  551.     add-text: method(text :: <string>) => (result :: <string>);
  552.               if (*Icap*) as-uppercase(text) else text end
  553.           end method,
  554.     tag-start: tag-start-recurse,
  555.     tag-close: tag-close-nothing);
  556.  
  557. add-tag(#["B", "STRONG"],
  558.     add-text: method(text :: <string>) => (result :: <string>);
  559.               if (*Bcap*) as-uppercase(text) else text end
  560.           end method,
  561.     tag-start: tag-start-recurse,
  562.     tag-close: tag-close-nothing);
  563.  
  564. // Anchors do nothing at all.
  565. add-tag(#["A", "HEAD", "BODY", "UNKNOWN", "TT", "CODE", "SAMP", "KBD"],
  566.     tag-start: tag-start-recurse,
  567.     tag-close: tag-close-nothing);
  568.  
  569. // Titles are eliminated entirely -- add-text simply "adds" an empty string.
  570. add-tag(#["TITLE"], 
  571.     add-text: method(text :: <string>) => (res :: <string>); "" end method,
  572.     tag-start: tag-start-recurse,
  573.     tag-close: tag-close-nothing);
  574.  
  575. // For un-bracketed environments like "<P>", "<BR>", etc. we must make sure
  576. // "tag-start" does not start a recursive call to "process-HTML".  We may or
  577. // may not want to dump accumulated text.
  578. add-tag(#["!"],
  579.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  580.                Out-Text :: <strings>, Current-Text :: <string>,
  581.                File :: <stream>, blank :: <boolean>)
  582.                => (result :: <string>, blank :: <boolean>);
  583.              values(Current-Text, blank);
  584.            end method);
  585.  
  586. add-tag(#["P"],
  587.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  588.                Out-Text :: <strings>, Current-Text :: <string>,
  589.                File :: <stream>, blank :: <boolean>)
  590.                => (result :: <string>, blank :: <boolean>);
  591.              values(Current-Text,
  592.                 break-up(Old-Tag, Out-Text, blank, #t));
  593.            end method);
  594.  
  595. add-tag(#["BR"], 
  596.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  597.                Out-Text :: <strings>, Current-Text :: <string>,
  598.                File :: <stream>, blank :: <boolean>)
  599.                => (result :: <string>, blank :: <boolean>);
  600.              if (Pre-Count > 0)
  601.                add-eol(Out-Text);
  602.                values(Current-Text, blank);
  603.              else
  604.                values(Current-Text,
  605.                   break-up(Old-Tag, Out-Text, blank, #f));
  606.              end if;
  607.            end method);
  608.  
  609. add-tag(#["HR"],
  610.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  611.                Out-Text :: <strings>, Current-Text :: <string>,
  612.                File :: <stream>, blank :: <boolean>)
  613.                => (result :: <string>, blank :: <boolean>);
  614.              break-up(Old-Tag, Out-Text, blank, #t);
  615.              write-line(concatenate('-' * *linelen*, "\n"),
  616.                 *standard-output*);
  617.              values(Current-Text, #t);
  618.            end method);
  619.  
  620. add-tag(#["IMG"],
  621.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  622.                Out-Text :: <strings>, Current-Text :: <string>,
  623.                File :: <stream>, blank :: <boolean>)
  624.                => (result :: <string>, blank :: <boolean>);
  625.              break-up(Old-Tag, Out-Text, blank, #t);
  626.              write-line(concatenate(' ' * *margin* + 4,
  627.                         "*** INLINE IMAGE IGNORED ***\n"),
  628.                 *standard-output*);
  629.              values(Current-Text, #t);
  630.            end method);
  631.  
  632. // Preformatted text is tricky.  First we dump accumulated text.  Then we
  633. // increment the global variable "Pre-Count" which enables magic behavior in
  634. // several standard routines.  Finally, when the environment is closed, we
  635. // split the output around the newlines and do line-by-line output so that the
  636. // left margin will be observed.
  637. add-tag(#["PRE"],
  638.     break-up: method (text :: <string>, blank :: <boolean>,
  639.               want-blank :: <boolean>) => (result :: <boolean>);
  640.             unless(blank) write('\n', *standard-output*); end;
  641.             let first = sfind(text, curry(\~=, '\n'));
  642.             let last = rsfind(text,
  643.                       complement(rcurry(member?, "\n ")));
  644.             if (last)
  645.               while (first < last)
  646.             let endline = sfind(text, curry(\=, '\n'),
  647.                         start: first, failure: last + 1);
  648.             print-with-prefix(text, start: first, end: endline);
  649.             first := endline + 1;
  650.               end while;
  651.             end if;
  652.             write-string("\n");
  653.             #t
  654.           end method,
  655.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  656.                Out-Text :: <strings>, Current-Text :: <string>,
  657.                File :: <stream>, blank :: <boolean>)
  658.                => (result :: <string>, blank :: <boolean>);
  659.              let blank = break-up(Old-Tag, Out-Text, blank, #t);
  660.              block ()
  661.                Pre-Count := Pre-Count + 1;
  662.                process-HTML(New-Tag, Out-Text, Current-Text,
  663.                     File, blank);
  664.              cleanup
  665.                Pre-Count := Pre-Count - 1;
  666.              end block;
  667.            end method);
  668.  
  669. // Since the following methods add nested indentation levels, we create a
  670. // stack for the margins.  A "document state" record might be cleaner, but is
  671. // probably overkill for this particular application.
  672. define constant margins :: <Deque> = make(<Deque>);
  673.  
  674. add-tag(#["UL", "OL", "MENU", "DL", "BLOCKQUOTE"],
  675.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  676.                Out-Text :: <strings>, Current-Text :: <string>,
  677.                File :: <stream>, blank :: <boolean>)
  678.                => (result :: <string>, blank :: <boolean>);
  679.              break-up(Old-Tag, Out-Text, blank, #t);
  680.              let OldCounter = counter;
  681.              block ()
  682.                push(margins, *margin*);
  683.                *margin* := *margin* + 4;
  684.                counter := 0;
  685.                process-HTML(New-Tag, Out-Text, Current-Text,
  686.                     File, blank);
  687.              cleanup
  688.                *margin* := pop(margins);
  689.                counter := OldCounter;
  690.              end block;
  691.            end method);
  692.  
  693. // The "<LI>" tag causes bullets or numbers to be printed before the
  694. // immediately following text.  We use a global "prefix" variable to magically
  695. // change the behavior of the next call to "print-with-prefix".  The precise
  696. // choice of prefix depends upon the enclosing environment.
  697. add-tag(#["LI"],
  698.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  699.                Out-Text :: <strings>, Current-Text :: <string>,
  700.                File :: <stream>, blank :: <boolean>)
  701.                => (result :: <string>, blank :: <boolean>);
  702.              let blank = break-up(Old-Tag, Out-Text, blank, #f);
  703.              if (Old-Tag = #"OL")
  704.                counter := counter + 1;
  705.                prefix := copy-sequence("0. ");
  706.                prefix[0] := as(<character>,
  707.                        counter + as(<integer>, '0'));
  708.              else
  709.                prefix := "* ";
  710.              end if;
  711.              values(Current-Text, blank);
  712.            end method);
  713.  
  714. // In "<DL>" environments, we must simply switch the left margin back and
  715. // forth between "unindented" and "indented" depending on whether we are
  716. // currently processing a "term" or a "definition".
  717. add-tag(#["DT"],
  718.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  719.                Out-Text :: <strings>, Current-Text :: <string>,
  720.                File :: <stream>, blank :: <boolean>)
  721.                => (result :: <string>, blank :: <boolean>);
  722.              let blank = break-up(Old-Tag, Out-Text, blank, #f);
  723.              *margin* := first(margins);
  724.              values(Current-Text, blank);
  725.            end method);
  726.  
  727. add-tag(#["DD"],
  728.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  729.                Out-Text :: <strings>, Current-Text :: <string>,
  730.                File :: <stream>, blank :: <boolean>)
  731.                => (result :: <string>, blank :: <boolean>);
  732.              let blank = break-up(Old-Tag, Out-Text, blank, #f);
  733.              *margin* := first(margins) + 4;
  734.              values(Current-Text, blank);
  735.            end method);
  736.  
  737. // Headers may centered and/or underlined and ignore margins.  They must still
  738. // be broken up into lines, although we use a shorter line-length.
  739. add-tag(#["H1"],
  740.     break-up: method (text :: <string>, blank :: <boolean>,
  741.               want-blank :: <boolean>)  => (result :: <boolean>);
  742.             unless(blank) write('\n', *standard-output*); end;
  743.             let first = sfind(text, curry(\~=, ' ')); 
  744.             let Text-Size = size(text);
  745.             let Find-Break = 
  746.               method (first, last)
  747.             if (last >= Text-Size)
  748.               Text-Size;
  749.             else 
  750.               let find = rsfind(text, curry(\=, ' '),
  751.                         start: first, end: last); 
  752.               if (find)   
  753.                 rsfind(text, curry(\~=, ' '), 
  754.                    start: first, end: find) + 1 
  755.               else 
  756.                 sfind(text, curry(\=, ' '), start: first)
  757.                   | size(text)
  758.               end if
  759.             end if
  760.               end method; 
  761.             let Max-Length = 0;
  762.             while (first)
  763.               let last = Find-Break(first, first + *linelen* - 20);
  764.               Max-Length := max(Max-Length, last - first);
  765.               write-string(' ' * truncate/(*linelen* + first - last,
  766.                            2));
  767.               write-line(text, *standard-output*,
  768.                  start: first, end: last); 
  769.               first := sfind(text, curry(\~=, ' '), start: last + 1)
  770.             end while;
  771.             if (*H1under*)
  772.               write-string(' ' * truncate/(*linelen* - Max-Length, 2));
  773.               write-line('=' * Max-Length, *standard-output*); 
  774.             end if;
  775.             if (want-blank) write-string("\n")  end if; 
  776.             want-blank 
  777.           end method);
  778.  
  779. add-tag(#["H2"],
  780.     break-up: method (text :: <string>, blank :: <boolean>,
  781.               want-blank :: <boolean>)  => (result :: <boolean>);
  782.             unless(blank) write('\n', *standard-output*); end;
  783.             let first = sfind(text, curry(\~=, ' ')); 
  784.             let Text-Size = size(text);
  785.             let Find-Break = 
  786.               method (first, last)
  787.             if (last >= Text-Size)
  788.               Text-Size;
  789.             else 
  790.               let find = rsfind(text, curry(\=, ' '),
  791.                         start: first, end: last); 
  792.               if (find)   
  793.                 rsfind(text, curry(\~=, ' '), 
  794.                    start: first, end: find) + 1 
  795.               else 
  796.                 sfind(text, curry(\=, ' '), start: first)
  797.                   | size(text)
  798.               end if
  799.             end if
  800.               end method; 
  801.             let Max-Length = 0;
  802.             while (first)
  803.               let last = Find-Break(first, first + *linelen* - 20);
  804.               Max-Length := max(Max-Length, last - first);
  805.               write-line(text, *standard-output*,
  806.                  start: first, end: last); 
  807.               first := sfind(text, curry(\~=, ' '), start: last + 1)
  808.             end while;
  809.             if (*H2under*)
  810.               write-line('-' * Max-Length, *standard-output*);
  811.               #f;
  812.             else
  813.               write('\n', *standard-output*);
  814.               #t
  815.             end if;
  816.           end method);
  817.  
  818. add-tag(#["H3", "H4", "H5", "H6"],
  819.     break-up: method (text :: <string>, blank :: <boolean>,
  820.               want-blank :: <boolean>)  => (result :: <boolean>);
  821.             unless(blank) write('\n', *standard-output*); end;
  822.             block ()
  823.               push(margins, *margin*);
  824.               *margin* := 0;
  825.               add-text-table[#"TEXT"](text, #t, want-blank);
  826.             cleanup
  827.               *margin* := pop(margins);
  828.             end;
  829.           end method);
  830.